home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / fonts.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  16KB  |  449 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'xlib :use '(lisp))
  20.  
  21. (export '(
  22.       open-font
  23.       discard-font-info
  24.       close-font
  25.       list-font-names
  26.       list-fonts
  27.       font-path))
  28.  
  29. ;; The char-info stuff is here instead of CLX because of uses of int16->card16.
  30.  
  31. ; To allow efficient storage representations, the type char-info is not
  32. ; required to be a structure.
  33.  
  34. ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
  35.  
  36. ;(defun char-<metric> (font index)
  37. ;  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
  38. ;  ;; (or an in-bounds index on a pseudo font), although returning zero or
  39. ;  ;; signalling might be better.
  40. ;  (declare (type font font)
  41. ;       (type integer index)
  42. ;       (values (or null integer))))
  43.  
  44. ;(defun max-char-<metric> (font)
  45. ;  ;; Note: I have tentatively chosen separate accessors over allowing :min and
  46. ;  ;; :max as an index above.
  47. ;  (declare (type font font)
  48. ;       (values integer)))
  49.  
  50. ;(defun min-char-<metric> (font)
  51. ;  (declare (type font font)
  52. ;       (values integer)))
  53.  
  54. ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
  55.  
  56. (deftype char-info-vec () '(simple-array int16 (6)))
  57.  
  58. (eval-when (eval compile) ;; I'd rather use macrolet, but Symbolics doesn't like it...
  59.  
  60. (defmacro def-char-info-accessors (useless-name &body fields)
  61.   `(within-definition (,useless-name def-char-info-accessors)
  62.      ,@(do ((field fields (cdr field))
  63.         (n 0 (1+ n))
  64.         (name) (type)
  65.         (result nil))
  66.        ((endp field) result)
  67.      (setq name (xintern 'char- (caar field)))
  68.      (setq type (cadar field))
  69.      (flet ((from (form)
  70.           (if (eq type 'int16)
  71.               form
  72.               `(,(xintern 'int16-> type) ,form))))
  73.        (push
  74.          `(defun ,name (font index)
  75.         (declare (type font font)
  76.              (type array-index index))
  77.         (declare-values ,type)
  78.         (let ((char-info-vector (font-char-infos font))
  79.               (char-entry (index+ (index* 6 (index+ (font-min-char font) index))
  80.                       ,n)))
  81.           (declare (type char-info-vec char-info-vector)
  82.                (type array-index char-entry))
  83.           (the ,type
  84.                ,(from
  85.               `(the int16
  86.                 (if (index< char-entry (length char-info-vector))
  87.                     ;; Variable width font
  88.                     (aref char-info-vector char-entry)
  89.                     ;; Fixed width font
  90.                     (aref (the char-info-vec (font-max-bounds font))
  91.                       ,n)))))))
  92.          result)
  93.        (push `(proclaim '(inline ,name)) result)
  94.        (setq name (xintern 'min-char- (caar field)))
  95.        (push
  96.          `(defun ,name (font)
  97.         (declare (type font font))
  98.         (declare-values ,type)
  99.         (the ,type ,(from `(the int16
  100.                     (aref (the char-info-vec (font-min-bounds font))
  101.                           ,n)))))
  102.          result)
  103.        (push `(proclaim '(inline ,name)) result)
  104.        (setq name (xintern 'max-char- (caar field)))
  105.        (push
  106.          `(defun ,name (font)
  107.         (declare (type font font))
  108.         (declare-values ,type)
  109.         (the ,type ,(from `(the int16
  110.                     (aref (the char-info-vec (font-max-bounds font))
  111.                           ,n)))))
  112.          result)
  113.        (push `(proclaim '(inline ,name)) result)))
  114.       
  115.      (defun make-char-info
  116.         (&key ,@(mapcar
  117.               #'(lambda (field)
  118.               `(,(car field) (required-arg ,(car field))))
  119.               fields))
  120.        (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
  121.        (let ((result (make-array ,(length fields) :element-type 'int16)))
  122.      (declare-array char-info-vec result)
  123.      ,@(do* ((field fields (cdr field))
  124.          (var (caar field) (caar field))
  125.          (type (cadar field) (cadar field))
  126.          (n 0 (1+ n))
  127.          (result nil))
  128.         ((endp field) (nreverse result))
  129.          (push `(setf (aref result ,n)
  130.               ,(if (eq type 'int16)
  131.                    var
  132.                    `(,(xintern type '->int16) ,var)))
  133.            result))
  134.      result))))
  135. ) ;; End eval-when
  136.  
  137. (def-char-info-accessors ignore
  138.   (left-bearing int16)
  139.   (right-bearing int16)
  140.   (width int16)
  141.   (ascent int16)
  142.   (descent int16)
  143.   (attributes card16))
  144.     
  145. (defun open-font (display name)
  146.   ;; Font objects may be cached and reference counted locally within the display
  147.   ;; object.  This function might not execute a with-display if the font is cached.
  148.   ;; The protocol QueryFont request happens on-demand under the covers.
  149.   (declare (type display display)
  150.        (type stringable name))
  151.   (declare-values font)
  152.   (let* ((name-string (string-downcase (string name)))
  153.      (font (car (member name-string (display-font-cache display)
  154.                 :key 'font-name
  155.                 :test 'equal)))
  156.      font-id)
  157.     (unless font
  158.       (setq font (make-font :display display :name name-string))
  159.       (setq font-id (allocate-resource-id display font 'font))
  160.       (setf (font-id-internal font) font-id)
  161.       (with-buffer-request (display *x-openfont*)
  162.     (resource-id font-id)
  163.     (card16 (length name-string))
  164.     (pad16 nil)
  165.     (string name-string))
  166.       (push font (display-font-cache display)))
  167.     (incf (font-reference-count font))
  168.     font))
  169.  
  170. (defun open-font-internal (font)
  171.   ;; Called "under the covers" to open a font object
  172.   (declare (type font font))
  173.   (declare-values resource-id)
  174.   (let* ((name-string (font-name font))
  175.      (display (font-display font))
  176.      (id (allocate-resource-id display font 'font)))
  177.     (setf (font-id-internal font) id)
  178.     (with-buffer-request (display *x-openfont*)
  179.       (resource-id id)
  180.       (card16 (length name-string))
  181.       (pad16 nil)
  182.       (string name-string))
  183.     (push font (display-font-cache display))
  184.     (incf (font-reference-count font))
  185.     id))
  186.  
  187. (defun discard-font-info (font)
  188.   ;; Discards any state that can be re-obtained with QueryFont.  This is
  189.   ;; simply a performance hint for memory-limited systems.
  190.   (declare (type font font))
  191.   (setf (font-font-info-internal font) nil
  192.     (font-char-infos-internal font) nil))
  193.  
  194. (defun query-font (font)
  195.   ;; Internal function called by font and char info accessors
  196.   (declare (type font font))
  197.   (declare-values font-info)
  198.   (let ((display (font-display font))
  199.     font-id
  200.     font-info
  201.     props)
  202.     (with-display (display)
  203.       (setq font-id (font-id font)) ;; May issue an open-font request
  204.       (with-buffer-request (display *x-queryfont* :no-after)
  205.     (resource-id font-id))
  206.       (wait-for-reply display nil)
  207.       (reading-buffer-reply (display)
  208.     (buffer-input display buffer-bbuf *replysize* 60)
  209.     (let* ((min-byte2 (card16-get 40))
  210.            (max-byte2 (card16-get 42))
  211.            (min-byte1 (card8-get 49))
  212.            (max-byte1 (card8-get 50))
  213.            (min-char  min-byte2)
  214.            (max-char  (+ (ash max-byte1 8) max-byte2))
  215.            (nfont-props (card16-get 46))
  216.            (nchar-infos (* (card32-get 56) 6))
  217.            (char-info (make-array nchar-infos :element-type 'int16)))
  218.       (setq font-info
  219.         (make-font-info
  220.           :direction (member8-get 48 :left-to-right :right-to-left)
  221.           :min-char min-char
  222.           :max-char max-char
  223.           :min-byte1 min-byte1
  224.           :max-byte1 max-byte1
  225.           :min-byte2 min-byte2
  226.           :max-byte2 max-byte2
  227.           :all-chars-exist-p (boolean-get 51)
  228.           :default-char (card16-get 44)
  229.           :ascent (int16-get 52)
  230.           :descent (int16-get 54)
  231.           :min-bounds (char-info-get 8)
  232.           :max-bounds (char-info-get 24)))
  233.       (setq props (sequence-get :length (* 2 nfont-props) :format int32
  234.                     :result-type 'list))
  235.       (sequence-get :length nchar-infos :format int16 :data char-info)
  236.       (setf (font-char-infos-internal font) char-info)
  237.       (setf (font-font-info-internal font) font-info)
  238.       )))
  239.     (display-invoke-after-function display)
  240.     ;; Replace atom id's with keywords in the plist
  241.     (do ((p props (cddr p)))
  242.     ((endp p))
  243.       (setf (car p) (lookup-xatom display (car p))))
  244.     (setf (font-info-properties font-info) props)
  245.     font-info))
  246.  
  247. (defun close-font (font)
  248.   ;; This might not generate a protocol request if the font is reference
  249.   ;; counted locally.
  250.   (declare (type font font))
  251.   (when (and (not (plusp (decf (font-reference-count font))))
  252.          (font-id-internal font))
  253.     (let ((display (font-display font))
  254.       (id (font-id-internal font)))
  255.       (declare (type display display))
  256.       ;; Remove font from cache
  257.       (setf (display-font-cache display) (delete font (display-font-cache display)))
  258.       ;; Close the font
  259.       (with-buffer-request (display *x-closefont*)
  260.     (resource-id id)))))
  261.  
  262. (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
  263.   (declare (type display display)
  264.        (type string pattern)
  265.        (type card16 max-fonts)
  266.        (type t result-type)) ;; CL type
  267.   (declare-values (sequence string))
  268.   (let ((string (string pattern))
  269.     result)
  270.     (with-display (display)
  271.       (with-buffer-request (display *x-listfonts* :no-after)
  272.     (card16 max-fonts (length string))
  273.     (string string))
  274.       (reading-buffer-reply (display :sizes 16)
  275.     (let ((length (- (wait-for-reply display nil) *replysize*))
  276.           (nfonts (card16-get 8)))
  277.       (setq result (read-sequence-string display length nfonts result-type)))))
  278.     (display-invoke-after-function display)
  279.     result))
  280.  
  281. (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
  282.   ;; Note: Was called list-fonts-with-info.
  283.   ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
  284.   ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
  285.   ;; converted (internally) to real fonts dynamically as needed, by issuing an
  286.   ;; OpenFont request.  However, the OpenFont might fail, in which case the
  287.   ;; invalid-font error can arise.
  288.   (declare (type display display)
  289.        (type string pattern)
  290.        (type card16 max-fonts)
  291.        (type t result-type)) ;; CL type
  292.   (declare-values (sequence font))
  293.   (let ((string (string pattern))
  294.     (result nil))
  295.     (with-display (display)
  296.       (with-buffer-request (display *x-listfontswithinfo* :no-after)
  297.     (card16 max-fonts (length string))
  298.     (string string))
  299.       (loop
  300.     ;; The font info's come in seperate reply packets
  301.     (wait-for-reply display nil)
  302.     (reading-buffer-reply (display)
  303.       (buffer-input display buffer-bbuf *replysize* 60)
  304.       (when (zerop (card8-get 1))
  305.         (return))
  306.       (let* ((name-len (card8-get 1))
  307.          (min-byte2 (card16-get 40))
  308.          (max-byte2 (card16-get 42))
  309.          (min-byte1 (card8-get 49))
  310.          (max-byte1 (card8-get 50))
  311.          (min-char  min-byte2)
  312.          (max-char  (+ (ash max-byte1 8) max-byte2))
  313.          (nfont-props (card16-get 46))
  314.          (font
  315.            (make-font
  316.              :display display
  317.              :name nil
  318.              :font-info-internal
  319.              (make-font-info
  320.                :direction (member8-get 48 :left-to-right :right-to-left)
  321.                :min-char min-char
  322.                :max-char max-char
  323.                :min-byte1 min-byte1
  324.                :max-byte1 max-byte1
  325.                :min-byte2 min-byte2
  326.                :max-byte2 max-byte2
  327.                :all-chars-exist-p (boolean-get 51)
  328.                :default-char (card16-get 44)
  329.                :ascent (int16-get 52)
  330.                :descent (int16-get 54)
  331.                :min-bounds (char-info-get 8)
  332.                :max-bounds (char-info-get 24)
  333.                :properties (sequence-get :length (* 2 nfont-props)
  334.                          :format int32
  335.                          :result-type 'list)))))
  336.         (setf (font-name font) (string-get name-len))
  337.         (push font result)))))
  338.     (display-invoke-after-function display)
  339.     ;; Replace atom id's with keywords in the plist
  340.     (dolist (font result)
  341.       (do ((p (font-properties font) (cddr p)))
  342.       ((endp p))
  343.     (setf (car p) (lookup-xatom display (car p)))))
  344.     (coerce (nreverse result) result-type)))
  345.  
  346. #+comment ;beta protocol
  347. (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
  348.   ;; Note: Was called list-fonts-with-info.
  349.   ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
  350.   ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
  351.   ;; converted (internally) to real fonts dynamically as needed, by issuing an
  352.   ;; OpenFont request.  However, the OpenFont might fail, in which case the
  353.   ;; invalid-font error can arise.
  354.   (declare (type display display)
  355.        (type string pattern)
  356.        (type card16 max-fonts)
  357.        (type t result-type)) ;; CL type
  358.   (declare-values (sequence font))
  359.   (let ((string (string pattern))
  360.     result)
  361.     (with-display (display)
  362.       (with-buffer-request (display *x-listfontswithinfo* :no-after)
  363.     (card16 max-fonts (length string))
  364.     (string string))
  365.       (reading-buffer-reply (display :sizes (8 16))
  366.     (let ((length (- (wait-for-reply display nil) *replysize*))
  367.           (nfonts (card16-get 8)))
  368.       (setq result (read-sequence-string display length nfonts result-type))
  369.       ;; The font info's come in seperate reply packets
  370.       (dotimes (i nfonts)
  371.         (buffer-input display buffer-bbuf 8 60)
  372.         (let* ((min-byte2 (card16-get 40))
  373.            (max-byte2 (card16-get 42))
  374.            (min-byte1 (card8-get 49))
  375.            (max-byte1 (card8-get 50))
  376.            (min-char  min-byte2)
  377.            (max-char  (+ (ash max-byte1 8) max-byte2))
  378.            (nfont-props (card16-get 46))
  379.            (font
  380.              (make-font
  381.                :display display
  382.                :name (elt result i)
  383.                :font-info-internal
  384.                (make-font-info
  385.              :direction (member8-get 48 :left-to-right :right-to-left)
  386.              :min-char min-char
  387.              :max-char max-char
  388.              :min-byte1 min-byte1
  389.              :max-byte1 max-byte1
  390.              :min-byte2 min-byte2
  391.              :max-byte2 max-byte2
  392.              :all-chars-exist-p (boolean-get 51)
  393.              :default-char (card16-get 44)
  394.              :ascent (int16-get 52)
  395.              :descent (int16-get 54)
  396.              :min-bounds (char-info-get 8)
  397.              :max-bounds (char-info-get 24)
  398.              :properties (sequence-get :length (* 2 nfont-props)
  399.                            :format int32
  400.                            :result-type 'list)))))
  401.           (setf (elt result i) font))))))
  402.       (display-invoke-after-function display)
  403.       ;; Replace atom id's with keywords in the plist
  404.       (dotimes (i (length result))
  405.     (do ((p (font-properties (elt result i)) (cddr p)))
  406.         ((endp p))
  407.       (setf (car p) (lookup-xatom display (car p)))))
  408.       result))
  409.  
  410. (defun font-path (display &key (result-type 'list))
  411.   (declare (type display display)
  412.        (type t result-type)) ;; CL type
  413.   (declare-values (sequence (or string pathname)))
  414.   (let (result)
  415.     (with-display (display)
  416.       (with-buffer-request (display *x-getfontpath* :no-after))
  417.       (reading-buffer-reply (display :sizes 16)
  418.     (let ((length (- (wait-for-reply display nil) *replysize*))
  419.           (nfonts (card16-get 8)))
  420.       (setq result (read-sequence-string display length nfonts result-type)))))
  421.     (display-invoke-after-function display)
  422.     result))
  423.  
  424. (defun set-font-path (display paths)
  425.   (declare (type display display)
  426.        (type sequence paths)) ;; (sequence (or string pathname))
  427.   (let ((path-length (length paths))
  428.     (request-length 8))
  429.     ;; Find the request length
  430.     (dotimes (i path-length)
  431.       (let* ((string (string (elt paths i)))
  432.          (len (length string)))
  433.     (incf request-length (1+ len))))
  434.     (with-buffer-request (display *x-setfontpath* :length request-length)
  435.       (length (ceiling request-length 4))
  436.       (card16 path-length)
  437.       (pad16 nil)
  438.       (progn
  439.     (incf buffer-boffset 8)
  440.     (dotimes (i path-length)
  441.       (let* ((string (string (elt paths i)))
  442.          (len (length string)))
  443.         (card8-put 0 len)
  444.         (string-put 1 string :appending t :header-length 1)
  445.         (incf buffer-boffset (1+ len))))
  446.     (setf (buffer-boffset display) (lround buffer-boffset))))))
  447.  
  448. (defsetf font-path set-font-path)
  449.